home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / vis082s.arc / TEXTRET.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-17  |  11KB  |  413 lines
  1. {$R-,S-,I-,D-,F+,V-,B-,N-,L+ }
  2.  
  3. unit textret;
  4.  
  5. interface
  6.  
  7. uses crt,gentypes,gensubs,subs1;
  8.  
  9. procedure reloadtext (sector:integer; var q:message);
  10. procedure deletetext (sector:integer);
  11. function maketext (var q:message):integer;
  12. function copytext (sector:integer):integer;
  13. procedure printtext (sector:integer);
  14.  
  15. implementation
  16.  
  17. procedure reloadtext (sector:integer; var q:message);
  18. var k:char;
  19.     sectorptr,tmp,n:integer;
  20.     buff:buffer;
  21.     x:boolean;
  22.  
  23.   procedure setbam (sector,val:integer);
  24.   begin
  25.     seek (mapfile,sector);
  26.     write (mapfile,val)
  27.   end;
  28.  
  29.   procedure chk;
  30.   begin
  31.     iocode:=ioresult;
  32.     if iocode<>0 then writeln (usr,'(Error ',iocode,' reading message)')
  33.   end;
  34.  
  35. begin
  36.   fillchar(q,sizeof(q),0);
  37.   sectorptr:=32767;
  38.   n:=1;
  39.   q.text[1]:='';
  40.   repeat
  41.     if sectorptr>sectorsize then begin
  42.       if sector<0 then exit;
  43.       seek (tfile,sector); chk;
  44.       read (tfile,buff); chk;
  45.       seek (mapfile,sector); chk;
  46.       read (mapfile,tmp); chk;
  47.       if tmp=-2 then begin
  48.         tmp:=-1;
  49.         seek (mapfile,sector); chk;
  50.         write (mapfile,tmp); chk;
  51.       end;
  52.       sector:=tmp;
  53.       sectorptr:=1
  54.     end;
  55.     k:=buff[sectorptr];
  56.     case k of
  57.       #0,#10:;
  58.       #13:if n>=maxmessagesize
  59.             then k:=#0
  60.             else begin
  61.               n:=n+1;
  62.               q.text[n]:=''
  63.             end
  64.       else q.text[n]:=q.text[n]+k
  65.     end;
  66.     sectorptr:=sectorptr+1
  67.   until k=#0;
  68.   q.numlines:=n;
  69.   chk
  70. end;
  71.  
  72. procedure deletetext (sector:integer);
  73. var next:integer;
  74.  
  75.   procedure setbam (sector,val:integer);
  76.   begin
  77.     seek (mapfile,sector);
  78.     write (mapfile,val)
  79.   end;
  80.  
  81. begin
  82.   while sector>=0 do begin
  83.     seek (mapfile,sector);
  84.     read (mapfile,next);
  85.     setbam (sector,-2);
  86.     sector:=next
  87.   end
  88. end;
  89.  
  90. function maketext (var q:message):integer;
  91. var line,pos,sector,prev:integer;
  92.     bufptr:integer;
  93.     curline:anystr;
  94.     k:char;
  95.     buff:buffer;
  96.     pbfft:message;
  97.  
  98.   procedure setbam (sector,val:integer);
  99.   begin
  100.     seek (mapfile,sector);
  101.     write (mapfile,val)
  102.   end;
  103.  
  104.   function nextblank (first:integer; linkit:boolean):integer;
  105.   var cnt,i,blank:integer;
  106.   begin
  107.     nextblank:=-1;
  108.     if first<-1 then first:=-1;
  109.     if first>=numsectors then exit;
  110.     seek (mapfile,first+1);
  111.     for cnt:=first+1 to numsectors do begin
  112.       read (mapfile,i);
  113.       if i=-2 then begin
  114.         blank:=cnt;
  115.         if (first>=0) and linkit then setbam (first,blank);
  116.         nextblank:=blank;
  117.         exit
  118.       end
  119.     end
  120.   end;
  121.  
  122.   function firstblank:integer;
  123.   begin
  124.     firstblank:=nextblank (-1,false)
  125.   end;
  126.  
  127.   procedure ensuretfilesize (sector:integer);
  128.   var cnt:integer;
  129.       buff:buffer;
  130.   begin
  131.     if sector<filesize(tfile) then exit;
  132.     if (sector<0) or (sector>numsectors) then exit;
  133.     fillchar (buff,sizeof(buff),'*');
  134.     seek (tfile,filesize(tfile));
  135.     for cnt:=filesize(tfile) to sector do write (tfile,buff);
  136.     fillchar (buff,sizeof(buff),'!')
  137.   end;
  138.  
  139.   procedure writesector (sector:integer; var q:buffer);
  140.   var n:integer;
  141.   begin
  142.     if (sector<0) or (sector>numsectors) then exit;
  143.     seek (mapfile,sector);
  144.     read (mapfile,n);
  145.     if n<>-2 then begin
  146.       error ('Overwrite error sector=%1!','',strr(sector));
  147.       exit
  148.     end;
  149.     ensuretfilesize (sector);
  150.     seek (tfile,sector);
  151.     write (tfile,q)
  152.   end;
  153.  
  154.   procedure flushbuf;
  155.   begin
  156.     writesector (sector,buff);
  157.     prev:=sector;
  158.     sector:=nextblank(prev,true);
  159.     bufptr:=1;
  160.   end;
  161.  
  162.   procedure outofroom;
  163.   begin
  164.     writeln (^B'Sorry, out of room!');
  165.     maketext:=-1
  166.   end;
  167.  
  168. begin
  169.   if q.numlines=0 then begin
  170.     writeln (^B'Message blank!');
  171.     maketext:=-1;
  172.     exit
  173.   end;
  174.   fillchar (pbfft,sizeof(pbfft),0);
  175.   pbfft:=q;
  176.   fillchar(q,sizeof(q),0);
  177.   q:=pbfft;
  178.   if firstfree>=0 then begin
  179.     sector:=firstfree;
  180.     seek (mapfile,sector);
  181.     read (mapfile,prev)
  182.   end else prev:=-1;
  183.   if prev<>-2 then begin
  184.     firstfree:=firstblank;
  185.     sector:=firstfree
  186.   end;
  187.   maketext:=sector;
  188.   if sector=-1 then begin
  189.     outofroom;
  190.     exit
  191.   end;
  192.   bufptr:=1;
  193.   for line:=1 to q.numlines do begin
  194.     curline:=q.text[line]+^M;
  195.     if line=q.numlines then curline:=curline+chr(0);
  196.     for pos:=1 to length(curline) do begin
  197.       k:=curline[pos];
  198.       buff[bufptr]:=k;
  199.       bufptr:=bufptr+1;
  200.       if bufptr>sectorsize then begin
  201.         flushbuf;
  202.         if sector=-1 then begin
  203.           outofroom;
  204.           exit
  205.         end
  206.       end
  207.     end
  208.   end;
  209.   if bufptr>1 then flushbuf;
  210.   setbam (prev,-1);
  211.   firstfree:=nextblank(firstfree,false);
  212.   if firstfree=-1 then firstfree:=firstblank
  213. end;
  214.  
  215. function copytext (sector:integer):integer;
  216. var me:message;
  217. begin
  218.   reloadtext (sector,me);
  219.   copytext:=maketext (me)
  220. end;
  221.  
  222.  
  223. procedure printtext (sector:integer);
  224. var q:message;
  225.     x,bub,done:boolean;
  226.     n,m,t,w,b,y,mm,i,apexiscool,e:integer;
  227.     p:byte;
  228.     s,a,cornerstone,sunbane:string;
  229.     cs,css,keithmillerisafag:char;
  230.     kay,thegog,kenny:char;
  231. begin
  232.   reloadtext (sector,q);
  233.   writeln (^B);
  234.   n:=1;
  235.   repeat
  236.    mm:=0;
  237.    repeat
  238.     if length(q.text[n])>0 then begin
  239.     p:=0;
  240.     mm:=mm+1;
  241.     s:=copy(q.text[n],mm,1);
  242.     if s='|' then p:=mm
  243.      else p:=0;
  244.     if p>0 then begin
  245.      cornerstone:=copy(q.text[n],p+1,1);
  246.      sunbane:=copy(q.text[n],p+2,1);
  247.      a:=(upcase(cornerstone[1]))+(upcase(sunbane[1]));
  248.      if
  249.       (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
  250.       (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
  251.       (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
  252.       (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') or
  253.       (a='KE') or (a='UN') or (a='CL') or (a='TI') or (a='DA'){ or (a='B0') or
  254.       (a='B1') or (a='B2') or (a='B3') or (a='B4') or (a='B5') or (a='B6') or
  255.       (a='B7')} or ((a[1]='P') and (valu(a[2])>0))
  256.       then begin
  257.       if
  258.       (a='00') or (a='01') or (a='02') or (a='03') or (a='04') or (a='05') or
  259.       (a='06') or (a='07') or (a='08') or (a='09') or (a='10') or (a='11') or
  260.       (a='12') or (a='13') or (a='14') or (a='15') or (a='16') or (a='17') or
  261.       (a='18') or (a='19') or (a='20') or (a='21') or (a='22') or (a='23') then
  262.      begin
  263.       delete (q.text[n],p+1,2);
  264.       b:=valu(a);
  265.       case b of
  266.        16:case curattrib of
  267.            0..15:b:=curattrib;
  268.            16..31:b:=curattrib-16;
  269.            32..47:b:=curattrib-32;
  270.            48..63:b:=curattrib-48;
  271.            64..79:b:=curattrib-64;
  272.            80..95:b:=curattrib-80;
  273.            96..111:b:=curattrib-96;
  274.            112..127:b:=curattrib-111;
  275.           end;
  276.        17:case curattrib of
  277.            0..15:b:=curattrib+16;
  278.            16..31:b:=curattrib;
  279.            32..47:b:=curattrib-16;
  280.            48..63:b:=curattrib-32;
  281.            64..79:b:=curattrib-48;
  282.            80..95:b:=curattrib-64;
  283.            96..111:b:=curattrib-80;
  284.            112..127:b:=curattrib-96;
  285.           end;
  286.        18:case curattrib of
  287.            0..15:b:=curattrib+32;
  288.            16..31:b:=curattrib+16;
  289.            32..47:b:=curattrib;
  290.            48..63:b:=curattrib-16;
  291.            64..79:b:=curattrib-32;
  292.            80..95:b:=curattrib-48;
  293.            96..111:b:=curattrib-64;
  294.            112..127:b:=curattrib-80;
  295.           end;
  296.        19:case curattrib of
  297.            0..15:b:=curattrib+48;
  298.            16..31:b:=curattrib+32;
  299.            32..47:b:=curattrib+16;
  300.            48..63:b:=curattrib;
  301.            64..79:b:=curattrib-16;
  302.            80..95:b:=curattrib-32;
  303.            96..111:b:=curattrib-48;
  304.            112..127:b:=curattrib-64;
  305.           end;
  306.        20:case curattrib of
  307.            0..15:b:=curattrib+64;
  308.            16..31:b:=curattrib+48;
  309.            32..47:b:=curattrib+32;
  310.            48..63:b:=curattrib+16;
  311.            64..79:b:=curattrib;
  312.            80..95:b:=curattrib-16;
  313.            96..111:b:=curattrib-32;
  314.            112..127:b:=curattrib-48;
  315.           end;
  316.        21:case curattrib of
  317.            0..15:b:=curattrib+80;
  318.            16..31:b:=curattrib+64;
  319.            32..47:b:=curattrib+48;
  320.            48..63:b:=curattrib+32;
  321.            64..79:b:=curattrib+16;
  322.            80..95:b:=curattrib;
  323.            96..111:b:=curattrib-16;
  324.            112..127:b:=curattrib-32;
  325.           end;
  326.        22:case curattrib of
  327.            0..15:b:=curattrib+96;
  328.            16..31:b:=curattrib+80;
  329.            32..47:b:=curattrib+64;
  330.            48..63:b:=curattrib+48;
  331.            64..79:b:=curattrib+32;
  332.            80..95:b:=curattrib+16;
  333.            96..111:b:=curattrib;
  334.            112..127:b:=curattrib-16;
  335.           end;
  336.        23:case curattrib of
  337.            0..15:b:=curattrib+111;
  338.            16..31:b:=curattrib+96;
  339.            32..47:b:=curattrib+80;
  340.            48..63:b:=curattrib+64;
  341.            64..79:b:=curattrib+48;
  342.            80..95:b:=curattrib+32;
  343.            96..111:b:=curattrib+16;
  344.            112..127:b:=curattrib;
  345.           end;
  346.         end;
  347.       if b=0 then ansicolor (0);
  348.       if (b<>0) then ansicolor (b);
  349.      end;
  350.      end;
  351.     { if a='KE' then
  352.      begin
  353.       delete (q.text[n],p+1,1);
  354.       delete (q.text[n],p+1,1);
  355.       write('*');
  356.       getstr;
  357.      end; }
  358.    {  if a='!@' then
  359.      begin
  360.       delete (q.text[n],p+1,1);
  361.       delete (q.text[n],p+1,1);
  362.       write('Press Any Key to continue.');
  363.       kenny:=readkey;
  364.      end; }
  365.      if a='UN' then
  366.      begin
  367.       delete (q.text[n],p+1,1);
  368.       delete (q.text[n],p+1,1);
  369.       write (urec.handle);
  370.      end;
  371.      if a='TI' then
  372.      begin
  373.       delete (q.text[n],p+1,1);
  374.       delete (q.text[n],p+1,1);
  375.       write (timestr(now));
  376.      end;
  377.      if a='DA' then
  378.      begin
  379.       delete (q.text[n],p+1,1);
  380.       delete (q.text[n],p+1,1);
  381.       write (datestr(now));
  382.      end;
  383.      if a='CL' then
  384.      begin
  385.       delete (q.text[n],p+1,1);
  386.       delete (q.text[n],p+1,1);
  387.       if (ansigraphics in urec.config) then write (#27+'[2J') else
  388.        write (^L);
  389.      end;
  390.      if ((a[1]='P') and (valu(a[2])>0)) then
  391.      begin
  392.       delete (q.text[n],p+1,1);
  393.       delete (q.text[n],p+1,1);
  394.       apexiscool:=valu(a[2]);
  395.       delay (apexiscool*1000);
  396.      end;
  397.    end else write (s);
  398.   end;
  399.   until mm=length(q.text[n]);
  400.    writeln;
  401.    n:=n+1;
  402.   until break or (n>q.numlines) or hungupon;
  403.   x:=xpressed; bub:=break;
  404.   writeln (^B^M);
  405.   xpressed:=x; break:=bub;
  406.   ansicolor (urec.regularcolor)
  407. end;
  408.  
  409. begin
  410. end.
  411.  
  412.  
  413.